home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-tar.el.z / tm-tar.el
Encoding:
Text File  |  1998-05-21  |  9.3 KB  |  345 lines
  1. ;;;
  2. ;;; $Id: tm-tar.el,v 1.22 1995/10/21 15:34:33 H.Ueno Exp $
  3. ;;;
  4. ;;; tm-tar.el
  5. ;;;
  6. ;;; Internal viewer for
  7. ;;;    - application/x-tar
  8. ;;;    - application/x-gzip, type="tar"
  9. ;;;    - aplication/octet-stream, type="tar"
  10. ;;;    - aplication/octet-stream, type="tar+gzip"
  11. ;;;
  12. ;;; by Hiroshi Ueno <zodiac@ibm.net>
  13. ;;;    modified by Tomohiko Morioka <morioka@jaist.ac.jp>
  14. ;;;
  15.  
  16. ;;; @ required modules
  17. ;;;
  18.  
  19. (require 'emu)
  20. (require 'tm-view)
  21.  
  22. ;;; @ constants
  23. ;;;
  24.  
  25. (defconst tm-tar/list-buffer "*tm-tar/List*")
  26. (defconst tm-tar/view-buffer "*tm-tar/View*")
  27. (defconst tm-tar/file-search-regexp "[0-9]+\:[0-9\:]+[ ]+[0-9]+[ ]+")
  28. (defconst tm-tar/popup-menu-title "Action Menu")
  29.  
  30. ;;; @ variables
  31. ;;;
  32.  
  33. (defvar tm-tar/tar-program  "gtar")
  34. (defvar tm-tar/tar-decompress-arg '("-z"))
  35. (defvar tm-tar/gzip-program "gzip")
  36. (defvar tm-tar/mmencode-program "mmencode")
  37. (defvar tm-tar/uudecode-program "uudecode")
  38.  
  39. (defvar tm-tar/popup-menu-items
  40.   '(("View File"         . tm-tar/view-file)
  41.     ("Key Help"          . tm-tar/helpful-message)
  42.     ("Quit tm-tar Mode"  . exit-recursive-edit)
  43.     ))
  44.  
  45. (cond ((string-match "XEmacs\\|Lucid" emacs-version)
  46.        (defvar tm-tar/popup-menu
  47.      (cons tm-tar/popup-menu-title
  48.         (mapcar (function
  49.             (lambda (item)
  50.               (vector (car item)(cdr item) t)
  51.               ))
  52.              tm-tar/popup-menu-items)))
  53.  
  54.        (defun tm-tar/mouse-button-2 (event)
  55.        (popup-menu tm-tar/popup-menu)
  56.        )
  57.        )
  58.       ((>= emacs-major-version 19)
  59.        (defun tm-tar/mouse-button-2 (event)
  60.      (let ((menu
  61.         (cons tm-tar/popup-menu-title
  62.             (list (cons "Menu Items" tm-tar/popup-menu-items))
  63.             )))
  64.        (let ((func (x-popup-menu event menu)))
  65.          (if func
  66.              (funcall func)
  67.            ))
  68.          ))
  69.        ))
  70.  
  71. (defvar tm-tar/tar-mode-map nil)
  72. (if tm-tar/tar-mode-map
  73.       nil
  74.     (setq tm-tar/tar-mode-map (make-keymap))
  75.     (suppress-keymap tm-tar/tar-mode-map)
  76.     (define-key tm-tar/tar-mode-map "\C-c"    'exit-recursive-edit)
  77.     (define-key tm-tar/tar-mode-map "q"       'exit-recursive-edit)
  78.     (define-key tm-tar/tar-mode-map "n"       'tm-tar/next-line)
  79.     (define-key tm-tar/tar-mode-map " "       'tm-tar/next-line)
  80.     (define-key tm-tar/tar-mode-map "\C-m"    'tm-tar/next-line)
  81.     (define-key tm-tar/tar-mode-map "p"       'tm-tar/previous-line)
  82.     (define-key tm-tar/tar-mode-map "\177"    'tm-tar/previous-line)
  83.     (define-key tm-tar/tar-mode-map "\C-\M-m" 'tm-tar/previous-line)
  84.     (define-key tm-tar/tar-mode-map "v"       'tm-tar/view-file)
  85.     (define-key tm-tar/tar-mode-map "\C-h"    'Helper-help)
  86.     (define-key tm-tar/tar-mode-map "?"       'tm-tar/helpful-message)
  87.     (if mouse-button-2
  88.     (define-key tm-tar/tar-mode-map
  89.                   mouse-button-2 'tm:button-dispatcher)
  90.     )
  91.   )
  92.  
  93. ;;; @@ tm-tar mode functions
  94. ;;;
  95.  
  96. (defun tm-tar/tar-mode (&optional prev-buf)
  97.   "Major mode for listing the contents of a tar archive file."
  98.     (unwind-protect
  99.     (let ((buffer-read-only t)
  100.           (mode-name "tm-tar")
  101.           (mode-line-buffer-identification '("%17b"))
  102.           )
  103.         (goto-char (point-min))
  104.         (tm-tar/move-to-filename)
  105.         (catch 'tm-tar/tar-mode (tm-tar/command-loop))
  106.      )
  107.     (if prev-buf
  108.         (switch-to-buffer prev-buf)
  109.      )
  110.      ))
  111.  
  112. (defun tm-tar/command-loop ()
  113.     (let ((old-local-map (current-local-map))
  114.       )
  115.     (unwind-protect
  116.         (progn
  117.         (use-local-map tm-tar/tar-mode-map)
  118.         (tm-tar/helpful-message)
  119.         (recursive-edit)
  120.          )
  121.         (save-excursion
  122.         (use-local-map old-local-map)
  123.          ))
  124.      ))
  125.  
  126. (defun tm-tar/next-line ()
  127.     (interactive)
  128.     (next-line 1)
  129.     (tm-tar/move-to-filename)
  130.   )
  131.  
  132. (defun tm-tar/previous-line ()
  133.     (interactive)
  134.     (previous-line 1)
  135.     (tm-tar/move-to-filename)
  136.   )
  137.  
  138. (defun tm-tar/view-file ()
  139.     (interactive)
  140.     (let ((name (tm-tar/get-filename))
  141.       )
  142.       (save-excursion
  143.       (switch-to-buffer tm-tar/view-buffer)
  144.       (setq buffer-read-only nil)
  145.       (erase-buffer)
  146.       (message "Reading a file from an archive. Please wait...")
  147.       (apply 'call-process tm-tar/tar-program
  148.              nil t nil (append tm-tar/view-args (list name)))
  149.       (goto-char (point-min))
  150.        )
  151.     (view-buffer tm-tar/view-buffer)
  152.      ))
  153.  
  154. (defun tm-tar/get-filename ()
  155.     (let (eol)
  156.     (save-excursion
  157.         (end-of-line)
  158.         (setq eol (point))
  159.         (beginning-of-line)
  160.         (save-excursion
  161.         (if (re-search-forward "^d" eol t)
  162.              (error "Cannot view a directory"))
  163.          )
  164.         (if (re-search-forward tm-tar/file-search-regexp eol t)
  165.              (progn (let ((beg (point))
  166.                   )
  167.                 (skip-chars-forward "^ \n")
  168.                 (buffer-substring beg (point))
  169.                 ))
  170.              (error "No file on this line")
  171.          ))
  172.      ))
  173.  
  174. (defun tm-tar/move-to-filename ()
  175.     (let ((eol (progn (end-of-line) (point)))
  176.       )
  177.     (beginning-of-line)
  178.     (re-search-forward tm-tar/file-search-regexp eol t)
  179.      ))
  180.  
  181. (defun tm-tar/set-properties ()
  182.     (if mouse-button-2
  183.     (let ((beg (point-min))
  184.           (end (point-max))
  185.           )
  186.         (goto-char beg)
  187.         (save-excursion
  188.         (while (re-search-forward tm-tar/file-search-regexp end t)
  189.             (tm:add-button (point)
  190.                        (progn
  191.                         (end-of-line)
  192.                         (point))
  193.                        'tm-tar/view-file)
  194.          ))
  195.      )))
  196.  
  197. (defun tm-tar/helpful-message ()
  198.     (interactive)
  199.     (message "Type %s, %s, %s, %s, %s, %s."
  200.     (substitute-command-keys "\\[Helper-help] for help")
  201.     (substitute-command-keys "\\[tm-tar/helpful-message] for keys")
  202.     (substitute-command-keys "\\[tm-tar/next-line] to next")
  203.     (substitute-command-keys "\\[tm-tar/previous-line] to prev")
  204.     (substitute-command-keys "\\[tm-tar/view-file] to view")
  205.     (substitute-command-keys "\\[exit-recursive-edit] to quit")
  206.      ))
  207.  
  208. (defun tm-tar/y-or-n-p (prompt)
  209.     (prog1
  210.     (y-or-n-p prompt)
  211.     (message "")
  212.      ))
  213.  
  214. ;;; @@ tar message decoder
  215. ;;
  216.  
  217. (defun mime/decode-message/tar (beg end cal)
  218.     (if (tm-tar/y-or-n-p "Do you want to enter tm-tar mode? ")
  219.     (let ((coding (cdr (assoc 'encoding cal)))
  220.           (cur-buf (current-buffer))
  221.           (tm-tar/tar-file-name (expand-file-name (concat (make-temp-name
  222.             (expand-file-name "tm" mime/tmp-dir)) ".tar")))
  223.           (tm-tar/tmp-file-name (expand-file-name (make-temp-name
  224.             (expand-file-name "tm" mime/tmp-dir))))
  225.           new-buf
  226.           )
  227.         (find-file tm-tar/tmp-file-name)
  228.         (setq new-buf (current-buffer))
  229.         (setq buffer-read-only nil)
  230.         (erase-buffer)
  231.         (save-excursion
  232.          (set-buffer cur-buf)
  233.         (goto-char beg)
  234.         (re-search-forward "^$")
  235.         (append-to-buffer new-buf (+ (match-end 0) 1) end)
  236.          )
  237.         (if (member coding mime-viewer/uuencode-encoding-name-list)
  238.         (progn
  239.             (goto-char (point-min))
  240.             (if (re-search-forward "^begin [0-9]+ " nil t)
  241.             (progn
  242.                 (kill-line)
  243.                 (insert tm-tar/tar-file-name)
  244.              )
  245.             (progn
  246.                 (set-buffer-modified-p nil)
  247.                 (kill-buffer new-buf)
  248.                 (error "uuencode file signature was not found")
  249.              ))))
  250.         (save-buffer)
  251.         (kill-buffer new-buf)
  252.         (message "Listing the contents of an archive.  Please wait...")
  253.         (cond ((string-equal coding "base64")
  254.            (call-process tm-tar/mmencode-program nil nil nil "-u"
  255.                 "-o" tm-tar/tar-file-name tm-tar/tmp-file-name)
  256.            )
  257.           ((string-equal coding "quoted-printable")
  258.            (call-process tm-tar/mmencode-program nil nil nil "-u" "-q"
  259.                 "-o" tm-tar/tar-file-name tm-tar/tmp-file-name)
  260.            )
  261.           ((member coding mime-viewer/uuencode-encoding-name-list)
  262.            (call-process tm-tar/uudecode-program nil nil nil
  263.                 tm-tar/tmp-file-name)
  264.            )
  265.           (t
  266.            (copy-file tm-tar/tmp-file-name tm-tar/tar-file-name t)
  267.            ))
  268.         (delete-file tm-tar/tmp-file-name)
  269.         (setq tm-tar/list-args (list "-tvf" tm-tar/tar-file-name))
  270.         (setq tm-tar/view-args (list "-xOf" tm-tar/tar-file-name))
  271.         (if (eq 0 (call-process tm-tar/gzip-program
  272.                 nil nil nil "-t" tm-tar/tar-file-name))
  273.         (progn
  274.             (setq tm-tar/list-args
  275.               (append tm-tar/tar-decompress-arg tm-tar/list-args))
  276.             (setq tm-tar/view-args
  277.               (append tm-tar/tar-decompress-arg tm-tar/view-args))
  278.          ))
  279.         (switch-to-buffer tm-tar/view-buffer)
  280.         (switch-to-buffer tm-tar/list-buffer)
  281.         (setq buffer-read-only nil)
  282.         (erase-buffer)
  283.         (apply 'call-process tm-tar/tar-program
  284.            nil t nil tm-tar/list-args)
  285.         (if mouse-button-2
  286.          (progn
  287.             (make-local-variable 'tm:mother-button-dispatcher)
  288.             (setq tm:mother-button-dispatcher 'tm-tar/mouse-button-2)
  289.          ))
  290.         (tm-tar/set-properties)
  291.         (tm-tar/tar-mode mime::article/preview-buffer)
  292.         (kill-buffer tm-tar/view-buffer)
  293.         (kill-buffer tm-tar/list-buffer)
  294.         (delete-file tm-tar/tar-file-name)
  295.      )
  296.      ))
  297.  
  298. ;;; @@ program/buffer coding system
  299. ;;;
  300.  
  301. (cond ((boundp 'MULE)
  302.        (define-program-coding-system tm-tar/view-buffer nil *autoconv*)
  303.        )
  304.       ((boundp 'NEMACS)
  305.        (define-program-kanji-code tm-tar/view-buffer nil 1)
  306.        ))
  307.  
  308. ;;; @@ message types to use tm-tar
  309. ;;;
  310.  
  311. (set-atype 'mime/content-decoding-condition
  312.        '((type . "application/octet-stream")
  313.          (method . mime/decode-message/tar)
  314.          (mode . "play") ("type" . "tar")
  315.          ))
  316.  
  317. (set-atype 'mime/content-decoding-condition
  318.        '((type . "application/octet-stream")
  319.          (method . mime/decode-message/tar)
  320.          (mode . "play") ("type" . "tar+gzip")
  321.          ))
  322.  
  323. (set-atype 'mime/content-decoding-condition
  324.        '((type . "application/x-gzip")
  325.          (method . mime/decode-message/tar)
  326.          (mode . "play") ("type" . "tar")
  327.          ))
  328.  
  329. (set-atype 'mime/content-decoding-condition
  330.        '((type . "application/x-tar")
  331.          (method . mime/decode-message/tar)
  332.          (mode . "play")
  333.          ))
  334.  
  335. ;;; @ end
  336. ;;;
  337.  
  338. (provide 'tm-tar)
  339.  
  340. ;;; Local Variables:
  341. ;;; mode: emacs-lisp
  342. ;;; mode: outline-minor
  343. ;;; outline-regexp: ";;; @+\\|(......"
  344. ;;; End:
  345.